home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / SEARCH.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  15.8 KB  |  458 lines

  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;;; Searches
  43.  
  44. ;;; **** For the time being all search and match operations are case
  45. ;;; insensitive.  This needs to be fixed later.  Also, the code has
  46. ;;; been bummed to know that strings are implemented as vectors of
  47. ;;; ASCII, and that char-sets are implemented as vectors of numbers.
  48.  
  49. ;;;; Character Search
  50.  
  51. (define (make-find-next-char substring-find-next-char)
  52.   (lambda (start end char)
  53.     (let ((start-line (mark-line start))
  54.       (end-line (mark-line end)))
  55.       (define (loop line)
  56.     (if (eq? line end-line)
  57.         (let ((index
  58.            (substring-find-next-char (line-string line)
  59.                          0
  60.                          (mark-position end)
  61.                          char)))
  62.           (and index (make-mark line index)))
  63.         (or (let ((index
  64.                (substring-find-next-char (line-string line)
  65.                          0
  66.                          (line-length line)
  67.                          char)))
  68.           (and index (make-mark line index)))
  69.         (loop (line-next line)))))
  70.       (cond ((char=? #\newline char)
  71.          (and (not (eq? start-line end-line))
  72.           (make-mark start-line (line-length start-line))))
  73.         ((eq? start-line end-line)
  74.          (let ((index
  75.             (substring-find-next-char (line-string start-line)
  76.                           (mark-position start)
  77.                           (mark-position end)
  78.                           char)))
  79.            (and index (make-mark start-line index))))
  80.         (else
  81.          (or (let ((index
  82.             (substring-find-next-char (line-string start-line)
  83.                           (mark-position start)
  84.                           (line-length start-line)
  85.                           char)))
  86.            (and index (make-mark start-line index)))
  87.          (loop (line-next start-line))))))))
  88.  
  89. (define find-next-char
  90.   (make-find-next-char substring-find-next-char-ci))
  91.  
  92. (define (find-next-newline start end)
  93.   (and (not (eq? (mark-line start) (mark-line end)))
  94.        (make-mark (mark-line start) (line-length (mark-line start)))))
  95.  
  96. (define (make-find-previous-char substring-find-previous-char)
  97.   (lambda (start end char)
  98.     ;; Here START must come after END in the mark ordering.
  99.     ;; The search begins at START and proceeds back until END.
  100.     (let ((start-line (mark-line start))
  101.       (end-line (mark-line end)))
  102.       (define (loop line)
  103.     (if (eq? line end-line)
  104.         (let ((index
  105.            (substring-find-previous-char (line-string line)
  106.                          (mark-position end)
  107.                          (line-length line)
  108.                          char)))
  109.           (and index (make-mark line (1+ index))))
  110.         (let ((index
  111.            (substring-find-previous-char (line-string line)
  112.                          0
  113.                          (line-length line)
  114.                          char)))
  115.           (if index
  116.           (make-mark line (1+ index))
  117.           (loop (line-previous line))))))
  118.       (cond ((char=? #\newline char))
  119.         ((eq? start-line end-line)
  120.         (let ((index
  121.                (substring-find-previous-char (line-string start-line)
  122.                              (mark-position end)
  123.                              (mark-position start)
  124.                              char)))
  125.           (and index (make-mark start-line (1+ index)))))
  126.         (else
  127.          (let ((index
  128.             (substring-find-previous-char (line-string start-line)
  129.                           0
  130.                           (mark-position start)
  131.                           char)))
  132.            (if index
  133.            (make-mark start-line (1+ index))
  134.            (loop (line-previous start-line)))))))))
  135.  
  136. (define find-previous-char
  137.   (make-find-previous-char substring-find-previous-char-ci))
  138.  
  139. (define (find-previous-newline start end)
  140.   (and (not (eq? (mark-line start) (mark-line end)))
  141.        (make-mark (mark-line start) 0)))
  142.  
  143. ;;;; Character-set Search
  144.  
  145. (define ((char-set-forward-search char-set) start end limit?)
  146.   (or (find-next-char-in-set start end char-set)
  147.       (limit-mark-motion limit? end)))
  148.  
  149. (define ((char-set-backward-search char-set) start end limit?)
  150.   (or (find-previous-char-in-set start end char-set)
  151.       (limit-mark-motion limit? end)))
  152.  
  153. (define (find-next-char-in-set start end char-set)
  154.   (let ((line (mark-line start))
  155.     (position (mark-position start))
  156.     (end-line (mark-line end))
  157.         (char-set-length (string-length char-set)))
  158.     (define (loop line)
  159.       (if (eq? line end-line)
  160.       (let ((index
  161.          (substring-find-next-char-in-set (line-string line)
  162.                           0
  163.                           (mark-position end)
  164.                           char-set)))
  165.         (and index (make-mark line index)))
  166.       (or (let ((index
  167.              (substring-find-next-char-in-set (line-string line)
  168.                               0
  169.                               (line-length line)
  170.                               char-set)))
  171.         (and index (make-mark line index)))
  172.           (loop (line-next line)))))
  173.     (if (eq? line end-line)
  174.     (let ((index
  175.            (substring-find-next-char-in-set (line-string line)
  176.                         position
  177.                         (mark-position end)
  178.                         char-set)))
  179.       (and index (make-mark line index)))
  180.     (or (let ((index
  181.            (substring-find-next-char-in-set (line-string line)
  182.                             position
  183.                             (line-length line)
  184.                             char-set)))
  185.           (and index (make-mark line index)))
  186. ;;;        (if (char-set-member? char-set #\Newline)
  187.             (if (substring-find-next-char-in-set char-set 0 char-set-length
  188.                                                  #\newline)
  189.         (make-mark line (line-length line))
  190.         (loop (line-next line)))))))
  191.  
  192. (define (find-previous-char-in-set start end char-set)
  193.   ;; Here START must come after END in the mark ordering.
  194.   ;; The search begins at START and proceeds back until END.
  195.   (let ((line (mark-line start))
  196.     (position (mark-position start))
  197.     (end-line (mark-line end))
  198.         (char-set-length (string-length char-set)))
  199.     (define (loop line)
  200.       (if (eq? line end-line)
  201.       (let ((index
  202.          (substring-find-previous-char-in-set (line-string line)
  203.                               (mark-position end)
  204.                               (line-length line)
  205.                               char-set)))
  206.         (and index (make-mark line (1+ index))))
  207.       (or (let ((index
  208.              (substring-find-previous-char-in-set (line-string line)
  209.                               0
  210.                               (line-length line)
  211.                               char-set)))
  212.         (and index (make-mark line (1+ index))))
  213.        (loop (line-previous line)))))
  214.     (if (eq? line end-line)
  215.     (let ((index
  216.            (substring-find-previous-char-in-set (line-string line)
  217.                             (mark-position end)
  218.                             position
  219.                             char-set)))
  220.       (and index (make-mark line (1+ index))))
  221.     (or (let ((index
  222.            (substring-find-previous-char-in-set (line-string line)
  223.                             0
  224.                             position
  225.                             char-set)))
  226.           (and index (make-mark line (1+ index))))
  227. ;;;        (if (char-set-member? char-set #\Newline)
  228.             (if (substring-find-next-char-in-set char-set 0 char-set-length
  229.                                                  #\newline)
  230.         (make-mark line 0)
  231.         (loop (line-previous line)))))))
  232.  
  233.  
  234. ;;;; String Search
  235.  
  236. (define (find-next-string start-mark end-mark string)
  237.   (find-next-substring start-mark end-mark
  238.                string 0 (string-length string)))
  239.  
  240. (define (find-next-substring start-mark end-mark
  241.                  string start end)
  242.   (if (= start end)
  243.       start-mark
  244.       (let ((start-bound (mark- end-mark (-1+ (- end start)) #F)))
  245.       (define (find-first mark)
  246.         (let ((first-char (find-next-char mark start-bound
  247.                           (string-ref string start))))
  248.         (and first-char
  249.          (if (match-next-substring first-char end-mark
  250.                        string start end)
  251.              first-char
  252.              (find-first (mark1+ first-char #F))))))
  253.     (and start-bound
  254.          (mark< start-mark start-bound)
  255.          (find-first start-mark)))))
  256.  
  257. (define (find-previous-string start-mark end-mark string)
  258.   (find-previous-substring start-mark end-mark
  259.                string 0 (string-length string)))
  260.  
  261. (define (find-previous-substring start-mark end-mark
  262.                  string start end)
  263.   (if (= start end)
  264.       start-mark
  265.       (let ((start-bound (mark+ end-mark (-1+ (- end start)) #F)))
  266.         (define (find-first mark)
  267.       (let ((first-char
  268.       (find-previous-char mark start-bound
  269.                      (string-ref string (-1+ end)))))
  270.         (and first-char
  271.              (if (match-previous-substring first-char end-mark
  272.                            string start end)
  273.              first-char
  274.              (find-first (mark-1+ first-char #F))))))
  275.     (and start-bound
  276.          (mark> start-mark start-bound)
  277.          (find-first start-mark)))))
  278.  
  279. ;;;; String Match
  280.  
  281. (define (match-next-strings start end strings)
  282.   (define (loop strings)
  283.     (and (not (null? strings))
  284.      (or (match-next-string start end (car strings))
  285.          (loop (cdr strings)))))
  286.   (loop strings))
  287.  
  288. (define (match-next-string start end string)
  289.   (match-next-substring start end string 0 (string-length string)))
  290.  
  291. (define (substring-next-newlines string start end)
  292.   (define (loop start)
  293.     (let ((newline (substring-find-next-char string start end #\newline)))
  294.       (if (not newline)
  295.       (list (- end start))
  296.       (cons newline (loop (1+ newline))))))
  297.   (loop start))
  298.  
  299. (define (match-previous-strings start end strings)
  300.   (define (loop strings)
  301.     (and (not (null? strings))
  302.      (or (match-previous-string start end (car strings))
  303.          (loop (cdr strings)))))
  304.   (loop strings))
  305.  
  306. (define (match-previous-string start end string)
  307.   (match-previous-substring start end string 0 (string-length string)))
  308.  
  309. (define (substring-previous-newlines string start end)
  310.   (define (loop end)
  311.     (let ((newline
  312.            (substring-find-previous-char string start end #\newline)))
  313.       (if (not newline)
  314.       (list (- end start))
  315.       (cons (1+ newline) (loop newline)))))
  316.   (loop end))
  317.  
  318. (define (match-next-substring start-mark end-mark string start end)
  319.   (let ((newlines (substring-next-newlines string start end))
  320.         (start-line (mark-line start-mark))
  321.     (start-position (mark-position start-mark))
  322.     (end-line (mark-line end-mark))
  323.     (end-position (mark-position end-mark)))
  324.     (define (match-rest line start newlines)
  325.       (cond ((eq? line end-line)
  326.          (and (null? (cdr newlines))
  327.           (<= (car newlines) end-position)
  328.           (substring-equal-ci? string start end
  329.                        (line-string line) 0
  330.                        (car newlines))
  331.           (make-mark line (car newlines))))
  332.         ((null? (cdr newlines))
  333.          (and (<= (car newlines) (line-length line))
  334.           (substring-equal-ci? string start end
  335.                        (line-string line) 0
  336.                        (car newlines))
  337.           (make-mark line (car newlines))))
  338.         (else
  339.          (and (substring-equal-ci? string start (car newlines)
  340.                        (line-string line) 0
  341.                        (line-length line))
  342.           (match-rest (line-next line)
  343.                   (1+ (car newlines))
  344.                   (cdr newlines))))))
  345.  
  346.     (cond ((eq? start-line end-line)
  347.        (and (null? (cdr newlines))
  348.         (let ((end-position* (+ start-position (car newlines))))
  349.           (and (<= end-position* end-position)
  350.                (substring-equal-ci? string start end
  351.                         (line-string start-line)
  352.                         start-position
  353.                         end-position*)
  354.                (make-mark start-line end-position*)))))
  355.       ((null? (cdr newlines))
  356.        (let ((end-position* (+ start-position (car newlines))))
  357.          (and (<= end-position* (line-length start-line))
  358.           (substring-equal-ci? string start end
  359.                        (line-string start-line)
  360.                        start-position
  361.                        end-position*)
  362.           (make-mark start-line end-position*))))
  363.       (else
  364.        (and (substring-equal-ci? string start (car newlines)
  365.                      (line-string start-line)
  366.                      start-position
  367.                      (line-length start-line))
  368.         (match-rest (line-next start-line)
  369.                 (1+ (car newlines))
  370.                 (cdr newlines)))))))
  371.  
  372. (define (match-previous-substring start-mark end-mark string start end)
  373.   ;; Here START-MARK must come after END-MARK in the mark ordering.
  374.   ;; The match begins at START-MARK and proceeds back until END-MARK.
  375.   (let ((newlines (substring-previous-newlines string start end))
  376.         (start-line (mark-line start-mark))
  377.     (start-position (mark-position start-mark))
  378.     (end-line (mark-line end-mark))
  379.     (end-position (mark-position end-mark)))
  380.     (define (match-rest line end newlines)
  381.       (cond ((eq? line end-line)
  382.          (and (null? (cdr newlines))
  383.           (<= end-position (car newlines))
  384.           (substring-equal-ci? string start end
  385.                        (line-string line) (car newlines)
  386.                        (line-length line))
  387.           (make-mark line (car newlines))))
  388.         ((null? (cdr newlines))
  389.          (and (<= 0 (car newlines))
  390.           (substring-equal-ci? string start end
  391.                        (line-string line) (car newlines)
  392.                        (line-length line))
  393.           (make-mark line (car newlines))))
  394.         (else
  395.          (and (substring-equal-ci? string (car newlines) end
  396.                        (line-string line) 0
  397.                        (line-length line))
  398.           (match-rest (line-next line)
  399.                   (-1+ (car newlines))
  400.                   (cdr newlines))))))
  401.  
  402.     (cond ((eq? start-line end-line)
  403.        (and (null? (cdr newlines))
  404.         (let ((end-position* (- start-position (car newlines))))
  405.           (and (<= end-position end-position*)
  406.                (substring-equal-ci? string start end
  407.                         (line-string start-line)
  408.                         end-position* start-position)
  409.                (make-mark start-line end-position*)))))
  410.       ((null? (cdr newlines))
  411.        (let ((end-position* (- start-position (car newlines))))
  412.          (and (<= 0 end-position*)
  413.           (substring-equal-ci? string start end
  414.                        (line-string start-line)
  415.                        end-position* start-position)
  416.           (make-mark start-line end-position*))))
  417.       (else
  418.        (and (substring-equal-ci? string (car newlines) end
  419.                      (line-string start-line) 0
  420.                      start-position)
  421.         (match-rest (line-next start-line)
  422.                 (-1+ (car newlines))
  423.                 (cdr newlines)))))))
  424.  
  425. ;;;; Character Match
  426.  
  427. (define (match-next-char start end char)
  428.   (and (mark< start end)
  429.        (let ((line (mark-line start))
  430.          (position (mark-position start)))
  431.      (if (= position (line-length line))
  432.          (and (char=? char #\newline)
  433.           (make-mark (line-next line) 0))
  434.          (and (char=? char (string-ref (line-string line) position))
  435.           (make-mark line (1+ position)))))))
  436.  
  437. (define (match-previous-char start end char)
  438.   (and (mark> start end)
  439.        (let ((line (mark-line start))
  440.          (position (-1+ (mark-position start))))
  441.      (if (negative? position)
  442.          (and (char=? char #\newline)
  443.           (make-mark (line-previous line)
  444.                  (line-length (line-previous line))))
  445.          (and (char=? char (string-ref (line-string line) position))
  446.           (make-mark line position))))))
  447.  
  448. (define (match-next-char-in-set start end char-set)
  449.   (and (mark< start end)
  450.        (char-set-member? char-set (mark-right-char start))
  451.        (mark1+ start #F)))
  452.  
  453. (define (match-previous-char-in-set start end char-set)
  454.   (and (mark> start end)
  455.        (char-set-member? char-set (mark-left-char start))
  456.        (mark-1+ start #F)))
  457.  
  458.